home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / MSDOS.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  12.8 KB  |  354 lines
  1. ; MSDOS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        MS-DOS Interface Routines                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 5 Jun 86:    Added new file and directory functions. (ds)        *
  18. ;* - 6 Jun 86:    DOS-CALL checks for .COM and .EXE files. (rb)        *
  19. ;* - 12 Jul 86:    Fixed a problem with dos/rename (dest drive). (ds)    *
  20. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  21. ;* - 23 Dec 92: Added synonym (delete-file f) (lb)            *
  22. ;* - 08 Jan 93:    Modified dos-copy & dos-rename using filename-split (mv)*
  23. ;*        dos-rename can now move files                *
  24. ;*                                    *
  25. ;*                    ``In nomine omnipotentii dei''    *
  26. ;************************************************************************
  27.  
  28. ;  The following Scheme function implements a directory listing
  29. ;  capability.  DOS-DIR is called with an MS-DOS filename specifier
  30. ;  which may contain wildcard characters, and returns a list of
  31. ;  the filenames which match the filespec.  For example,
  32. ;
  33. ;            (DOS-DIR "\\pcs\\*.ini")
  34. ;
  35. ;  might return the list:
  36. ;
  37. ;               ("SCHEME.INI" "HISTORY.INI")
  38. ;
  39. ; Remember that Scheme requires the backslash character "\" to be
  40. ; escaped, so you must specify two "\\"'s in a character string if
  41. ; you want to see one "\" (but slash is also accepted: "/pcs/*.ini").
  42.  
  43. (begin
  44.  
  45. (define dos-dir
  46.   (lambda (filespec)
  47.     (letrec ((dir1 (lambda ()
  48.              (let ((next (%esc 1)))
  49.                (if next
  50.                (cons next (dir1))
  51.                '())))))
  52.       (if (string? filespec)
  53.       (let ((next (%esc 0 filespec)))
  54.         (if next
  55.         (cons next (dir1))
  56.         '() ))
  57.       (%error-invalid-operand 'DOS-DIR filespec)))))
  58.  
  59.  
  60. (define (dos-get-env name)
  61.   (if (string? name)
  62.       (%esc 36 name)
  63.       (%error-invalid-operand 'DOS-GET-ENV name)))
  64.  
  65.  
  66. (define (dos-put-env name)
  67.   (if (string? name)
  68.       (not (zero? (%esc 37 name)))
  69.       (%error-invalid-operand 'DOS-PUT-ENV name)))
  70.  
  71.  
  72. (define (dos-search-file filespec)
  73.   (if (string? filespec)
  74.       (%esc 38 filespec)
  75.       (%error-invalid-operand 'DOS-SEARCH-FILE filespec)))
  76.  
  77.  
  78. ;  The DOS-CALL function permits a user to issue any MS-DOS command from
  79. ;  Scheme and return when the function has completed.  The format for
  80. ;  the DOS-CALL function is:
  81. ;
  82. ;        (dos-call "filename" "parameters"
  83. ;                {memory} {protect display})
  84. ;
  85. ;  where "filename" is the name of an .EXE or .COM file which is to
  86. ;            be executed.  If "filename" is a null (zero length)
  87. ;            string (i.e., ""), the "parameters" string is
  88. ;            passed to a new copy of COMMAND.COM.
  89. ;
  90. ;       "parameters" is the parameter string to be passed to the
  91. ;            application or COMMAND.COM.
  92. ;
  93. ;            If both "filename" and "parameters" are null
  94. ;            strings, DOS-CALL exits to MS-DOS COMMAND.COM and
  95. ;            stays there until the command EXIT is entered, at
  96. ;            which time PCS execution resumes.
  97. ;
  98. ;       "memory" is an optional argument which specifies the number
  99. ;            of paragraphs (16 byte units of memory) which are
  100. ;            to be freed up to run the requested task.  If this
  101. ;            argument is omitted, all available Scheme user
  102. ;            memory is made available to the task.  Note:
  103. ;            4096 paragraphs is equivalent to 64K bytes of
  104. ;            memory.
  105. ;
  106. ;      "protect display" is an optional argument which allows the current
  107. ;            screen to be left undisturbed when the external program
  108. ;            is being executed.  Note: this will only inhibit text
  109. ;            from being displayed to the screen for programs doing
  110. ;            screen i/o that doesn't bypass the BIOS (Lotus 1-2-3
  111. ;            does).
  112. ;
  113. ;   Scheme memory is freed up by copying it to disk in 4095 paragraph
  114. ;   (65,520 byte) blocks.  Specifying 4095 paragraphs instead of 4096 (to
  115. ;   make it an even 64K bytes) saves a slight bit of disk I/O overhead.
  116. ;
  117. ;   The value returned by DOS-CALL is an integer error code.    Zero
  118. ;   indicates no error; -1 indicates an argument error; positive values
  119. ;   are those returned by DOS itself.
  120.  
  121.  
  122. (define dos-call
  123.   (lambda args
  124.     (define (canonize parameters)
  125.       (list->string (append (cons (integer->char (string-length parameters))
  126.                                   (string->list parameters))
  127.                             (list #\return))))
  128.  
  129.     (let ((filename (if args (car args) ""))
  130.       (parameters (if (and args (cadr args)) (cadr args) ""))
  131.       (mem_req (if (cddr args) (car (cddr args)) 0))
  132.       (protect (if (= (length (cddr args)) 2) (cadr (cddr args)) 0))
  133.       (temp-window (%make-window '()))
  134.           (window-contents '()))
  135.       (if (and (string? filename)
  136.                (string? parameters))
  137.           (begin
  138.             (when (<= protect 0)
  139.               (window-set-size! temp-window 132 132) ; make sure we save everything
  140.                   (set! window-contents (%save-window temp-window))
  141.                   (%clear-window temp-window))
  142.             (begin0
  143.               (%esc 2
  144.                     (if (string-null? filename) (dos-get-env "COMSPEC") filename)
  145.                     (canonize (if (and (eqv? filename "")
  146.                                        (not (eqv? parameters "")))
  147.                                   (string-append "/c " parameters)
  148.                                   parameters))
  149.                     (truncate mem_req)
  150.                     protect)
  151.             
  152.               (when (<= protect 0)
  153.                     (if (< protect 0)
  154.                         (read-char))
  155.                     (let ((cur_pos (window-get-cursor 'console)))
  156.                       (%clear-window 'console)
  157.                       (window-set-cursor! 'console (car cur_pos) (cdr cur_pos))
  158.                       (%restore-window temp-window window-contents)))))
  159.           -1))))            ; else error code -1
  160.  
  161.  
  162. ;  The following Scheme function implements a software interrupt
  163. ;  capability.  SW-INT is called with an interrupt number between
  164. ;  0 and 255, a return result value, and up to four values which
  165. ;  will be stuffed into the registers ax,bc,cx,and dx.
  166. ;
  167. ;  Possible values for the return result are:
  168. ;        0 - INTEGER
  169. ;        1 - T OR NIL
  170. ;        2 - STRING
  171. ;
  172. ;  (SW-INT 112 0 100 "hello") -
  173. ;    Invokes interrupt 112 (or 70 hex). Register ax will be loaded
  174. ;    with a pointer to 100, bx will be loaded with a pointer to
  175. ;    the string "hello" and registers cx and dx are not used. The
  176. ;    return value is expected to be an integer. (return values are
  177. ;    handled the same way that Lattice C expects results from assembly
  178. ;    language programs.)
  179. ;
  180.  
  181. (define sw-int
  182.   (lambda args
  183.      (let ((int_num (car args))
  184.        (return_type (cadr args))
  185.        (ax (if (null? (cddr args)) "" (caddr args)))
  186.        (bx (if (null? (cdddr args)) "" (cadddr args)))
  187.        (cx (if (null? (cddddr args)) "" (car (cddddr args))))
  188.        (dx (if (null? (cdr(cddddr args))) "" (cadr(cddddr args)))))
  189.       (if (> (length args) 6)
  190.          (apply %error-invalid-operand-list (cons 'SW-INT args))
  191.          (if (or (< int_num 0) (> int_num 255))
  192.            (%error-invalid-operand 'SW-INT int_num)
  193.            (if (> return_type 3)
  194.          (%error-invalid-operand 'SW-INT return_type)
  195.          (%esc 7 int_num return_type ax bx cx dx)))))))
  196.  
  197. ;
  198. ; The following Scheme function implements a file deletion
  199. ; capability. DOS-DELETE is called with an MS-DOS filename
  200. ; specifier which may NOT contain wildcard characters. The file
  201. ; specification can contain drive and path specifications. An
  202. ; integer is returned indicating if the result was successful or not.
  203. ; A successful call will return 0, anything else indicates an error.
  204. ; For example:
  205. ;
  206. ;            (DOS-DELETE "temp.exe")
  207.  
  208. (define dos-delete
  209.   (lambda (filespec)
  210.      (if (string? filespec)
  211.      (if (file-exists? filespec)
  212.          (%esc 10 filespec)
  213.          (error
  214.            (string-append "DOS-DELETE: " filespec " does not exist!")))
  215.      (%error-invalid-operand 'DOS-DELETE filespec))))
  216. (define delete-file dos-delete)
  217.  
  218. ;
  219. ; The following Scheme function implements a capability to copy
  220. ; DOS files. DOS-FILE-COPY is called with two MS-DOS filename
  221. ; specifiers. The first file must exist in the current directory,
  222. ; the second will be over written over if it does exist or created
  223. ; if it doesn't. The file specifications may NOT contain wildcard
  224. ; characters. The source file can contain a path specification.
  225. ; A drive designator may be specified as the destination
  226. ; but the destination may not be blank. If just a drive designation
  227. ; is entered then the source file name is appended to the destination.
  228. ; An integer is returned indicating if the call was successful or not.
  229. ; A zero indicates a successfull call, anything else indicates an error.
  230. ; For example:
  231. ;
  232. ;            (DOS-FILE-COPY "temp.exe" "temp.xxx")
  233. ;
  234. ; Remember that Scheme requires the backslash character to be escaped,
  235. ; so you should better use unix-style "/" instead.
  236.  
  237. (define dos-file-copy
  238.   (lambda (filespec1 filespec2)
  239.      (if (and (string? filespec1) (string? filespec2))
  240.      (if (file-exists? filespec1)
  241.          (begin
  242.         (if (eqv? (caddr (filename-split filespec2)) "")
  243.           (set! filespec2
  244.                     (apply string-append
  245.                filespec2
  246.                       (cddr (filename-split filespec1)))))
  247.             (%esc 11 filespec1 filespec2))
  248.          (%error
  249.            (string-append "DOS-FILE-COPY: " filespec1 " does not exist!")))
  250.      (%error-invalid-operand-list 'DOS-FILE-COPY filespec1 filespec2))))
  251.  
  252. ;
  253. ;  The following Scheme function implements a capability to rename
  254. ;  files in the current directory. DOS-RENAME is called with two
  255. ;  MS-DOS filename specifiers. The first must exist and the second
  256. ;  cannot exist. The filename specifiers may NOT contain wildcard
  257. ;  characters, but they can both include path specifications.
  258. ;  If path are different, file is moved. An integer is returned
  259. ;  indicating if the call was successful or not. For example:
  260. ;
  261. ;            (DOS-RENAME "temp.exe" "temp.xxx")
  262. ;
  263. ; Remember that Scheme requires the backslash character to be escaped,
  264. ; so you should better use unix-style "/" instead.
  265.  
  266. (define dos-rename
  267.   (lambda (filespec1 filespec2)
  268.     (if (and (string? filespec1) (string? filespec2))
  269.     (if (file-exists? filespec1)
  270.         (begin
  271.           (if (eqv? (cadr (filename-split filespec2)) "")
  272.           (set! filespec2
  273.             (apply string-append
  274.                    (car (filename-split filespec1))
  275.                    (cadr (filename-split filespec1))
  276.                    (cddr (filename-split filespec2)))))
  277.           (if (file-exists? filespec2)
  278.           (%error
  279.             (string-append "DOS-RENAME: " filespec2 " already exists!")))
  280.           (%esc 12 filespec1 filespec2))
  281.         (%error
  282.           (string-append "DOS-RENAME: " filespec1 " does not exist!")))
  283.     (%error-invalid-operand-list 'DOS-RENAME filespec1 filespec2))))
  284.  
  285. ;
  286. ;  The following Scheme function implements a file size capability
  287. ;  DOS-FILE-SIZE is called with an MS-DOS filename specifier
  288. ;  which may NOT contain wildcard characters, and returns
  289. ;  an integer indicating the size of the file. For example:
  290. ;
  291. ;            (DOS-FILE-SIZE "temp.exe")
  292. ;
  293.  
  294. (define dos-file-size
  295.   (lambda (filespec)
  296.     (if (string? filespec)
  297.     (if (file-exists? filespec)
  298.         (%esc 15 filespec)
  299.         (%error
  300.           (string-append "DOS-FILE-SIZE: " filespec " does not exist!")))
  301.     (%error-invalid-operand 'DOS-FILE-SIZE filespec))))
  302.  
  303. ;
  304. ;  The following Scheme function implements a capability to change
  305. ;  the current directory. DOS-CHDIR is called with a string
  306. ;  containing the directory which will become the current directory.
  307. ;  A string is returned which contains the previous directory.
  308. ;  For example:
  309. ;
  310. ;            (DOS-CHDIR "a:\\source")
  311. ;
  312. ; Remember that Scheme requires the backslash character to be escaped,
  313. ; so you should better use unix-style "/" instead.
  314. ;
  315.  
  316. (define dos-chdir
  317.   (lambda directory
  318.      (if (null? directory)
  319.        (%esc 19 "@")
  320.      ;else
  321.        (if (string? (car directory))
  322.            (let ((dir (car directory)))
  323.              (begin0
  324.                (%esc 19 (if (and (> (string-length dir) 1)
  325.                        (equal? (string-ref dir 1) #\:))
  326.                 dir "@"))
  327.                (%esc 16 dir)))
  328.            (%error-invalid-operand 'DOS-CHDIR directory)))))
  329.  
  330. (define dos-get-dir
  331.   (lambda drive
  332.     (if (null? drive)
  333.       (%esc 19 "@")
  334.       (if (string? (car drive))
  335.         (%esc 19 (car drive))
  336.     (%error-invalid-operand 'DOS-GET-DIR drive)))))
  337.  
  338. ;
  339. ;  The following Scheme function implements a capability to change
  340. ;  the current drive. DOS-CHANGE-DRIVE is called with a string
  341. ;  containing the drive which is to become the current drive.
  342. ;  The dos error code is returned.
  343. ;  For example:
  344. ;
  345. ;            (DOS-CHANGE-DRIVE "a:")
  346. ;
  347.  
  348. (define dos-change-drive
  349.   (lambda (drive)
  350.      (if (string? drive)
  351.      (%esc 17 drive)
  352.      (%error-invalid-operand 'DOS-CHANGE-DRIVE drive))))
  353. )
  354.